home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-minibuf.el.z / vm-minibuf.el
Encoding:
Text File  |  1998-05-21  |  14.8 KB  |  404 lines
  1. ;;; Minibuffer read functions for VM
  2. ;;; Copyright (C) 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-minibuf)
  19.  
  20. (defun vm-minibuffer-complete-word (&optional exiting)
  21.   (interactive)
  22.   (let ((opoint (point))
  23.     trimmed-c-list c-list beg end diff word word-prefix-regexp completion)
  24.     ;; find the beginning and end of the word we're trying to complete
  25.     (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
  26.     (progn
  27.       (skip-chars-backward " \t\n")   
  28.       (and (not (eobp)) (forward-char))
  29.       (setq end (point)))
  30.       (skip-chars-forward "^ \t\n")
  31.       (setq end (point)))
  32.     ;; if there can't be multiple words in the input the beginning
  33.     ;; of the word must be at point-min.
  34.     (if (not vm-completion-auto-space)
  35.     (setq beg (point-min))
  36.       (skip-chars-backward "^ \t\n")
  37.       (setq beg (point)))
  38.     (goto-char opoint)
  39.     ;; copy the word into a string
  40.     (setq word (buffer-substring beg end))
  41.     ;; trim the completion list down to just likely candidates
  42.     ;; then convert it to an alist.
  43.     (setq word-prefix-regexp (concat "^" (regexp-quote word))
  44.       trimmed-c-list (vm-delete-non-matching-strings
  45.               word-prefix-regexp
  46.               vm-minibuffer-completion-table)
  47.       trimmed-c-list (sort trimmed-c-list (function string-lessp))
  48.       trimmed-c-list (mapcar 'list trimmed-c-list)
  49.       c-list (mapcar 'list vm-minibuffer-completion-table))
  50.     ;; Try the word against the completion list.
  51.     (and trimmed-c-list
  52.      (setq completion (try-completion word trimmed-c-list)))
  53.     ;; If completion is nil, figure out what prefix of the word would prefix
  54.     ;; something in the completion list... but only if the user is interested.
  55.     (if (and (null completion) vm-completion-auto-correct c-list)
  56.     (let ((i -1))
  57.       (while (null (setq completion
  58.                  (try-completion (substring word 0 i) c-list)))
  59.         (vm-decrement i))
  60.       (setq completion (substring word 0 i))))
  61.     ;; If completion is t, we had a perfect match already.
  62.     (if (eq completion t)
  63.     (cond (vm-completion-auto-space
  64.            (goto-char end)
  65.            (insert " "))
  66.           (t
  67.            (and (not exiting)
  68.             (vm-minibuffer-completion-message "[Sole completion]"))))
  69.       ;; Compute the difference in length between the completion and the
  70.       ;; word.  A negative difference means no match and the magnitude
  71.       ;; indicates the number of chars that need to be shaved off the end
  72.       ;; before a match will occur.  A positive difference means a match
  73.       ;; occurred and the magnitude specifies the number of new chars that
  74.       ;; can be appended to the word as a completion.
  75.       ;;
  76.       ;; `completion' can be nil here, but the code works anyway because
  77.       ;; (length nil) still equals 0!
  78.       (setq diff (- (length completion) (length word)))
  79.       (cond
  80.        ;; We have some completion chars.  Insert them.
  81.        ((> diff 0)
  82.     (goto-char end)
  83.     (insert (substring completion (- diff)))
  84.     (if (and vm-completion-auto-space
  85.          (null (cdr trimmed-c-list)))
  86.         (insert " ")))
  87.        ;; The word prefixed more than one string, but we can't complete
  88.        ;; any further.  Either give help or say "Ambiguous".
  89.        ((zerop diff)
  90.     (and (not exiting)
  91.          (cond ((> (length (car trimmed-c-list)) (length word))
  92.             (if (null completion-auto-help)
  93.             (vm-minibuffer-completion-message "[Ambiguous]")
  94.               (vm-minibuffer-show-completions (sort
  95.                                (mapcar 'car
  96.                                    trimmed-c-list)
  97.                                'string-lessp))))
  98.            ((not (eq last-command 'vm-minibuffer-complete-word))
  99.             (vm-minibuffer-completion-message
  100.              "[Complete, but not unique]"))
  101.            (vm-completion-auto-space
  102.             (insert " ")))))
  103.        ;; The word didn't prefix anything... if vm-completion-auto-correct is
  104.        ;; non-nil strip the offending characters and try again.
  105.        (vm-completion-auto-correct
  106.     (goto-char end)
  107.     (delete-char diff)
  108.     (vm-minibuffer-complete-word exiting))
  109.        ;; if we're not auto-correcting and we're doing
  110.        ;; multi-word, just let the user insert a space.
  111.        (vm-completion-auto-space
  112.     (insert " "))
  113.        ;; completion utterly failed, tell the user so.
  114.        (t
  115.     (and (not exiting)
  116.          (vm-minibuffer-completion-message "[No match]")))))))
  117.  
  118. (defun vm-minibuffer-complete-word-and-exit ()
  119.   (interactive)
  120.   (vm-minibuffer-complete-word t)
  121.   (exit-minibuffer))
  122.  
  123. (defun vm-minibuffer-completion-message (string &optional seconds)
  124.   "Briefly display STRING to the right of the current minibuffer input.
  125. Optional second arg SECONDS specifies how long to keep the message visible;
  126. the default is 2 seconds.
  127.  
  128. A keypress causes the immediate erasure of the STRING, and return of control
  129. to the calling program."
  130.   (let (omax (inhibit-quit t))
  131.     (save-excursion
  132.       (goto-char (point-max))
  133.       (setq omax (point))
  134.       (insert " " string))
  135.     (sit-for (or seconds 2))
  136.     (delete-region omax (point-max))))
  137.  
  138. (defun vm-minibuffer-replace-word (word)
  139.   (goto-char (point-max))
  140.   (skip-chars-backward "^ \t\n")
  141.   (delete-region (point) (point-max))
  142.   (insert word))
  143.  
  144. (defun vm-minibuffer-show-completions (list)
  145.   "Display LIST in a multi-column listing in the \" *Completions*\" buffer.
  146. LIST should be a list of strings."
  147.   (save-excursion
  148.     (set-buffer (get-buffer-create " *Completions*"))
  149.     (setq buffer-read-only nil)
  150.     (use-local-map (make-sparse-keymap))
  151.     ;; ignore vm-mutable-* here.  the user shouldn't mind
  152.     ;; because when they exit the minibuffer the windows will be
  153.     ;; set right again.
  154.     (display-buffer (current-buffer))
  155.     (erase-buffer)
  156.     (insert "Possible completions are:\n")
  157.     (setq buffer-read-only t)
  158.     (vm-show-list list 'vm-minibuffer-replace-word
  159.           (list (current-local-map) minibuffer-local-map))
  160.     (goto-char (point-min))))
  161.  
  162. (defun vm-show-list (list &optional function keymaps)
  163.   "Display LIST in a multi-column listing in the current buffer at point.
  164. The current buffer must be displayed in some window at the time
  165. this function is called.
  166.  
  167. LIST should be a list of strings.
  168.  
  169. Optional second argument FUNCTION will be called if the mouse is
  170. clicked on one of the strings in the current buffer.  The string
  171. clicked upon will be passed to FUNCTION as its sole argument.
  172.  
  173. Optional third argument KEYMAPS specifies a lists of keymaps
  174. where the FUNCTION should be bound to the mouse clicks.  By
  175. default the local keymap of the current buffer is used."
  176.   (or keymaps (setq keymaps (and (current-local-map)
  177.                  (list (current-local-map)))))
  178.   (save-excursion
  179.     (let ((buffer-read-only nil)
  180.       (separation 3)
  181.       tabs longest columns list-length q i w start command
  182.       keymap)
  183.       (cond ((and function keymaps (vm-mouse-support-possible-p))
  184.          (setq command
  185.            (list 'lambda '(e) '(interactive "e")
  186.              (list 'let
  187.                    '((string (vm-mouse-get-mouse-track-string e)))
  188.                    (list 'and 'string (list function 'string)))))
  189.          (while keymaps
  190.            (setq keymap (car keymaps))
  191.            (cond ((vm-mouse-xemacs-mouse-p)
  192.               (define-key keymap 'button1 command)
  193.               (define-key keymap 'button2 command))
  194.              ((vm-mouse-fsfemacs-mouse-p)
  195.               (define-key keymap [down-mouse-1] 'ignore)
  196.               (define-key keymap [drag-mouse-1] 'ignore)
  197.               (define-key keymap [mouse-1] command)
  198.               (define-key keymap [drag-mouse-2] 'ignore)
  199.               (define-key keymap [down-mouse-2] 'ignore)
  200.               (define-key keymap [mouse-2] command)))
  201.            (setq keymaps (cdr keymaps)))))
  202.       (setq list (sort (copy-sequence list) (function string-lessp))
  203.         w (vm-get-buffer-window (current-buffer))
  204.         q list
  205.         list-length 0
  206.         longest 0
  207.         columns (1- (window-width w)))
  208.       (while q
  209.     (setq longest (max longest (length (car q)))
  210.           list-length (1+ list-length)
  211.           q (cdr q)))
  212.       (setq tabs (/ list-length (/ columns (+ longest separation)))
  213.         tabs (+ tabs
  214.             (if (zerop (% list-length
  215.                   (/ columns (+ longest separation))))
  216.             0
  217.               1)))
  218.       (setq i 0)
  219.       (while (< i tabs)
  220.     (setq q (nthcdr i list))
  221.     (while q
  222.       (setq start (point))
  223.       (insert (car q))
  224.       (and function (vm-mouse-set-mouse-track-highlight start (point)))
  225.       (insert-char ?  (+ separation (- longest (length (car q)))))
  226.       (setq q (nthcdr tabs q)))
  227.     (setq i (1+ i))
  228.     (insert "\n")))))
  229.  
  230. (defun vm-minibuffer-completion-help ()
  231.   (interactive)
  232.   (let ((opoint (point))
  233.     c-list beg end word word-prefix-regexp)
  234.     ;; find the beginning and end of the word we're trying to complete
  235.     (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
  236.     (progn
  237.       (skip-chars-backward " \t\n")   
  238.       (and (not (eobp)) (forward-char))
  239.       (setq end (point)))
  240.       (skip-chars-forward "^ \t\n")
  241.       (setq end (point)))
  242.     (skip-chars-backward "^ \t\n")
  243.     (setq beg (point))
  244.     (goto-char opoint)
  245.     ;; copy the word into a string
  246.     (setq word (buffer-substring beg end))
  247.     ;; trim the completion list down to just likely candidates
  248.     ;; then convert it to an alist.
  249.     (setq word-prefix-regexp (concat "^" (regexp-quote word))
  250.       c-list (vm-delete-non-matching-strings
  251.           word-prefix-regexp
  252.           vm-minibuffer-completion-table)
  253.       c-list (sort c-list (function string-lessp)))
  254.     (if c-list
  255.     (vm-minibuffer-show-completions c-list)
  256.       (vm-minibuffer-completion-message " [No match]"))))
  257.  
  258. (defun vm-keyboard-read-string (prompt completion-list &optional multi-word)
  259.   (let ((minibuffer-local-map (copy-keymap minibuffer-local-map))
  260.     (vm-completion-auto-space multi-word)
  261.     (vm-minibuffer-completion-table completion-list))
  262.     (define-key minibuffer-local-map "\t" 'vm-minibuffer-complete-word)
  263.     (define-key minibuffer-local-map " " 'vm-minibuffer-complete-word)
  264.     (define-key minibuffer-local-map "?" 'vm-minibuffer-completion-help)
  265.     (if (not multi-word)
  266.     (define-key minibuffer-local-map "\r"
  267.       'vm-minibuffer-complete-word-and-exit))
  268.     ;; evade the XEmacs dialog box, yeccch.
  269.     (let ((use-dialog-box nil))
  270.       (read-string prompt))))
  271.  
  272. (defvar last-nonmenu-event)
  273.  
  274. (defun vm-read-string (prompt completion-list &optional multi-word)
  275.   ;; handle alist
  276.   (if (consp (car completion-list))
  277.       (setq completion-list (nreverse (mapcar 'car completion-list))))
  278.   (if (and completion-list (vm-mouse-support-possible-here-p))
  279.       (cond ((and (vm-mouse-xemacs-mouse-p)
  280.           (or (button-press-event-p last-command-event)
  281.               (button-release-event-p last-command-event)
  282.               (menu-event-p last-command-event)))
  283.          (vm-mouse-read-string prompt completion-list multi-word))
  284.         ((and (vm-mouse-fsfemacs-mouse-p)
  285.           (listp last-nonmenu-event))
  286.          (vm-mouse-read-string prompt completion-list multi-word))
  287.         (t
  288.          (vm-keyboard-read-string prompt completion-list multi-word)))
  289.     (vm-keyboard-read-string prompt completion-list multi-word)))
  290.  
  291. (defun vm-read-number (prompt)
  292.   (let (result)
  293.     (while
  294.     (null
  295.      (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt)))))
  296.     (string-to-int result)))
  297.  
  298. (defun vm-read-password (prompt &optional confirm)
  299.   "Read and return a password from the minibuffer, prompting with PROMPT.
  300. Optional second argument CONFIRM non-nil means that the user will be asked
  301.   to type the password a second time for confirmation and if there is a
  302.   mismatch, the process is repeated.
  303.  
  304. Line editing keys are:
  305.   C-h, DEL    rubout
  306.   C-u, C-x      line kill
  307.   C-q, C-v      literal next"
  308.   (catch 'return-value
  309.     (save-excursion
  310.       (let ((cursor-in-echo-area t)
  311.         (echo-keystrokes 0)
  312.         (input-buffer nil)
  313.         (help-form nil)
  314.         (xxx "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
  315.         (string nil)
  316.         char done form)
  317.     (unwind-protect
  318.         (save-excursion
  319.           (setq input-buffer (get-buffer-create " *password*"))
  320.           (set-buffer input-buffer)
  321.           (while t
  322.         (erase-buffer)
  323.         (message "%s%s" prompt
  324.                     (vm-truncate-string xxx (buffer-size)))
  325.         (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j)))
  326.           (if (setq form
  327.                 (cdr
  328.                  (assq char
  329.                    '((?\C-h . (delete-char -1))
  330.                      (?\C-? . (delete-char -1))
  331.                      (?\C-u . (delete-region 1 (point)))
  332.                      (?\C-x . (delete-region 1 (point)))
  333.                      (?\C-q . (quoted-insert 1))
  334.                      (?\C-v . (quoted-insert 1))))))
  335.               (condition-case error-data
  336.               (eval form)
  337.             (error t))
  338.             (insert char))
  339.           (message "%s%s" prompt
  340.                       (vm-truncate-string xxx (buffer-size))))
  341.         (cond ((and confirm string)
  342.                (cond ((not (string= string (buffer-string)))
  343.                   (message
  344.                    (concat prompt
  345.                        (vm-truncate-string xxx (buffer-size))
  346.                        " [Mismatch... try again.]"))
  347.                   (ding)
  348.                   (sit-for 2)
  349.                   (setq string nil))
  350.                  (t (throw 'return-value string))))
  351.               (confirm
  352.                (setq string (buffer-string))
  353.                (message
  354.             (concat prompt
  355.                 (vm-truncate-string xxx (buffer-size))
  356.                 " [Retype to confirm...]"))
  357.                (sit-for 2))
  358.               (t
  359.                (message "")
  360.                (throw 'return-value (buffer-string))))))
  361.       (and input-buffer (kill-buffer input-buffer)))))))
  362.  
  363. (defun vm-keyboard-read-file-name (prompt &optional dir default
  364.                       must-match initial history)
  365.   "Like read-file-name, except HISTORY's value is unaltered."
  366.   (let ((oldvalue (symbol-value history))
  367.     ;; evade the XEmacs dialog box, yeccch.
  368.     (use-dialog-box nil))
  369.     (unwind-protect
  370.     (condition-case nil
  371.         (read-file-name prompt dir default must-match initial history)
  372.       (wrong-number-of-arguments
  373.        (if history
  374.            (let ((file-name-history (symbol-value history))
  375.              file)
  376.          (setq file
  377.                (read-file-name prompt dir default must-match initial))
  378.          file )
  379.          (read-file-name prompt dir default must-match initial))))
  380.       (and history (set history oldvalue)))))
  381.  
  382. (defun vm-read-file-name (prompt &optional dir default
  383.                  must-match initial history)
  384.   "Like read-file-name, except a mouse interface is used if a mouse
  385. click mouse triggered the current command."
  386.   (if (vm-mouse-support-possible-here-p)
  387.       (cond ((and (vm-mouse-xemacs-mouse-p)
  388.           (or (button-press-event-p last-command-event)
  389.               (button-release-event-p last-command-event)
  390.               (menu-event-p last-command-event)))
  391.          (vm-mouse-read-file-name prompt dir default
  392.                       must-match initial history))
  393.         ((and (vm-mouse-fsfemacs-mouse-p)
  394.           (listp last-nonmenu-event))
  395.          (vm-mouse-read-file-name prompt dir default
  396.                       must-match initial history))
  397.         (t
  398.          (vm-keyboard-read-file-name prompt dir default
  399.                      must-match initial history)))
  400.     (vm-keyboard-read-file-name prompt dir default
  401.                 must-match initial history)))
  402.  
  403.  
  404.